C----------------------------------------------------------------------------

C Module name: PHIGS menus utility

C Author: Karen Wyrwas

C Function: This module contains the PHIGS utility routines
C for menus and high level input tools. They are all built on top of PHIGS.

C Hashtables used: "structureid", "name", "label".

C Modification history: (Version), (Date), (Name), (Description).

C 1.0, 9th March 1988, Karen Wyrwas, First version.

C 1.1, 31st October 1988, Karen Wyrwas, Add rotator routines.

C 1.2, 1st November 1988, Karen Wyrwas, Port to VAX PHIGS.

C 2.0, 25th April 1991, Gareth Williams, Translated to C.

C 2.1, 16th May 1991, Gareth Williams, Functions getmenu, getmenuid,
C disposemenus, ptk_inqpickmenus added.

C 2.2, 23rd May 1991, Gareth Williams, Built rotators on top of user menus.

C---------------------------------------------------------------------------

       SUBROUTINE ptkf_createusermenu(menuid, menustid)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{menustid}{menu structure identifier}{IN}
C ** \paramend
C ** \blurb{This function creates a user menu using the structure
C ** {\tt menustid}. Each menu item must be an individual PHIGS
C ** structure or network and the menu initially contains no menu items.}
C */
       INTEGER menuid, menustid
       external ptk_createusermenu !$PRAGMA C(ptk_createusermenu)

       call ptk_createusermenu(%val(menuid), %val(menustid))

       RETURN
       END

       SUBROUTINE ptkf_createboxmenu(menuid, tlcorner, boxsize)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{REAL}{tlcorner(2)}{top left corner of menu}{IN}
C ** \param{REAL}{boxsize(2)}{width and height of menu box item}{IN}
C ** \paramend
C ** \blurb{This function creates a box menu with no initial items.
C ** The position of the menu is specified by {\tt tlcorner} which
C ** defines the top-left corner of the first menu item. The position
C ** and size of box menu items are given in the range [0, 1]. The default
C ** menu path is DOWN.}
C */
       INTEGER menuid
       REAL tlcorner(3), boxsize(2)
       external ptk_createboxmenu !$PRAGMA C(ptk_createboxmenu)

       call ptk_createboxmenu(%val(menuid), tlcorner, boxsize)

       RETURN
       END
       
       SUBROUTINE ptkf_createtextmenuitem(menuid, str, itemno,
& editmode, error)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{CHARACTER*(*)}{str}{text string}{IN}
C ** \param{INTEGER}{itemno}{menu item number}{IN}
C ** \param{INTEGER}{editmode}{insert or replace menu item.}{IN}
C ** \param{INTEGER}{error}{error code}{IN}
C ** \paramend
C ** \blurb{This function creates a box menu item containing the character
C ** string {\tt str}. The string is automatically scaled to fit inside
C ** the menu item box. This function may only be used with box menus.}
C ** 
C */
       INTEGER menuid
       CHARACTER*(*) str
       INTEGER itemno, editmode, error
       CHARACTER*255 inbuf
       external ptk_createtextmenuitem 
& !$PRAGMA C(ptk_createtextmenuitem)

       inbuf = str//'\0'
       call ptk_createtextmenuitem(%val(menuid), str, %val(itemno),
&  %val(editmode), error)

       RETURN
       END
       
       SUBROUTINE ptkf_createstructmenuitem(menuid, structid, itemno, 
& editmode, error)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{structid}{menu item structure identifier}{IN}
C ** \param{INTEGER}{itemno}{menu item number}{IN}
C ** \param{INTEGER}{editmode}{insert or replace menu item}{IN}
C ** \param{INTEGER}{error}{error code}{IN}
C ** \paramend
C ** \blurb{This function creates a menu item defined by {\tt structure}.
C ** In the case of box menus the structure is mapped into the item box
C ** with aspect ratio preserved. No transformation is applied for user
C ** menu items.}
C */
       INTEGER menuid, structid
       INTEGER itemno, editmode, error
       external ptk_createstructmenuitem 
& !$PRAGMA C(ptk_createstructmenuitem)

       call  ptk_createstructmenuitem(%val(menuid), %val(structid), 
& %val(itemno), %val(editmode), error)

       RETURN
       END
       
       LOGICAL FUNCTION ptkf_delmenu(menuid)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \paramend
C ** \blurb{This function deletes a menu from the PHIGS Toolkit menu store.
C ** The function returns TRUE if {\tt menuid} is deleted, otherwise FALSE.}
C */
       INTEGER menuid
       LOGICAL*1 ptk_delmenu, ans
       external ptk_delmenu !$PRAGMA C(ptk_delmenu)

       ans = ptk_delmenu(%val(menuid))
       if (ans .eq. 1) then
          ptkf_delmenu = .TRUE.
       else
          ptkf_delmenu = .FALSE.
       endif

       RETURN
       END
       
       LOGICAL FUNCTION ptkf_delmenuitem(menuid, itemno)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{itemno}{menu item to delete}{IN}
C ** \paramend
C ** \blurb{This function deletes the menu item {\tt itemno}.
C ** The function returns TRUE if the menu item is deleted, otherwise FALSE.}
C */
       INTEGER menuid, itemno
       LOGICAL*1 ptk_delmenuitem, ans
       external ptk_delmenuitem !$PRAGMA C(ptk_delmenuitem)

       ans = ptk_delmenuitem(%val(menuid), %val(itemno))
       if (ans .eq. 1) then
          ptkf_delmenuitem = .TRUE.
       else
          ptkf_delmenuitem = .FALSE.
       endif

       RETURN
       END
       
       SUBROUTINE ptkf_frontmenu(wsid, menuid)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \paramend 
C ** \blurb{This function sets the post priority of the menu structure
C ** so that it is displayed on top of all the other posted menus and
C ** windows.}
C */
       INTEGER wsid, menuid
       external ptk_frontmenu !$PRAGMA C(ptk_frontmenu)

       call ptk_frontmenu(%val(wsid), %val(menuid))
       RETURN
       END
       
       SUBROUTINE ptkf_backmenu(wsid, menuid)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \paramend 
C ** \blurb{This function sets the post priority of the menu structure so
C ** that it is displayed below all other posted menus but in front of
C ** all posted windows.}
C */
       INTEGER wsid, menuid
       external ptk_backmenu !$PRAGMA C(ptk_backmenu)

       call ptk_backmenu(%val(wsid), %val(menuid))

       RETURN
       END
       
       SUBROUTINE ptkf_postmenu(wsid, menuid)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \paramend
C ** \blurb{This function posts the menu structure to the workstation
C ** {\tt wsid}. The priority of the menu structure is controlled by the
C ** PHIGS Toolkit menu system to provide an ordered stacking of displayed
C ** menus. When {\tt menuid} is posted it becomes the front menu.} 
C */
       INTEGER wsid, menuid
       external ptk_postmenu !$PRAGMA C(ptk_postmenu)

       call ptk_postmenu(%val(wsid), %val(menuid))

       RETURN
       END
       
       SUBROUTINE ptkf_unpostmenu(wsid, menuid)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \paramend
C ** \blurb{This function unposts a menu structure from the workstation
C ** {\tt wsid}. The front and back menus are updated if necessary.}
C */
       INTEGER wsid, menuid
       external ptk_unpostmenu !$PRAGMA C(ptk_unpostmenu)

       call ptk_unpostmenu(%val(wsid), %val(menuid))

       RETURN
       END

       SUBROUTINE ptkf_unpostallmenu(wsid)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \paramend
C ** \blurb{This function unposts all menus from the workstation {\tt wsid}.}
C */
       INTEGER wsid
       external ptk_unpostallmenu !$PRAGMA C(ptk_unpostallmenu)

       call ptk_unpostallmenu(%val(wsid))

       RETURN
       END
       
       LOGICAL FUNCTION ptkf_stringscanmenus(wsid, str, menuid, itemnum)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{CHARACTER*(*)}{str}{string}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{OUT}
C ** \param{INTEGER}{itemno}{item number}{OUT}
C ** \paramend
C ** \blurb{This function compares the character string {\tt str} with
C ** the items of all posted menus. The comparison begins with the
C ** highest priority menu and works through to the back menu.
C ** User menu items are also searched for text primitives with which to
C ** compare the string. The comparison is case sensitive so that
C ** "item 1" is not the same as "IteM 1".
C ** The function returns TRUE if the string matches a menu item, 
C ** otherwise FALSE.}
C */
       INTEGER wsid
       CHARACTER*(*) str
       INTEGER menuid, itemnum
       LOGICAL*1 ptk_stringscanmenus, ans
       CHARACTER*255 inbuf
       external ptk_stringscanmenus !$PRAGMA C(ptk_stringscanmenus)

       inbuf = str//'\0'
       ans = ptk_stringscanmenus(%val(wsid), inbuf, menuid, itemnum)
       if (ans .eq. 1) then
          ptkf_stringscanmenus = .TRUE.
       else
          ptkf_stringscanmenus = .FALSE.
       endif

       RETURN
       END

       LOGICAL FUNCTION ptkf_pickscanmenus(ippd, pp, ppordr, menuid, 
& itemnum)
C /*
C ** \parambegin
C ** \param{INTEGER}{ippd}{depth of pick path}{IN}
C ** \param{INTEGER}{pp(3, ippd)}{pick path through structure network.}{IN}
C ** \param{INTEGER}{ppordr}{order of data in pickpath}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{OUT}
C ** \param{INTEGER}{itemnum}{item number}{OUT}
C ** \paramend
C ** \blurb{This function tests the pick path to inquire if a menu item
C ** was picked. 
C ** The function returns TRUE if a menu item was picked, otherwise FALSE.}
C */
       INTEGER ippd
       INTEGER pp(3, ippd)
       INTEGER ppordr
       INTEGER menuid, itemnum
       LOGICAL*1 ptkc_pickscanmenus, ans
       external ptkc_pickscanmenus !$PRAGMA C(ptkc_pickscanmenus)

       ans = ptkc_pickscanmenus(%val(ippd), pp, %val(ppordr), menuid, 
& itemnum)
       if (ans .eq. 1) then
          ptkf_pickscanmenus = .TRUE.
       else
          ptkf_pickscanmenus = .FALSE.
       endif

       RETURN
       END

       LOGICAL FUNCTION ptkf_locscanmenus(wsid, point, menuid, itemnum, 
& value)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{REAL}{point(2)}{input point}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{OUT}
C ** \param{INTEGER}{itemnum}{item number}{OUT}
C ** \param{REAL}{value(2)}{position of point within item}{OUT}
C ** \paramend
C ** \blurb{This function uses the INCREMENTAL SPATIAL SEARCH function 
C ** of PHIGS to test if {\tt point} lies within a posted menu.
C ** The menus are tested begining the highest priority menu and working 
C ** through to the back menu. The position of {\tt point} relative
C ** to bottom-left corner of the menu item bounding box is returned
C ** in {\tt value}.
C ** The function returns TRUE if {\tt point} lies within a menu, 
C ** otherwise FALSE.}
C */
       INTEGER wsid
       REAL point(2)
       INTEGER menuid, itemnum
       REAL value(2)
       LOGICAL*1 ptk_locscanmenus, ans
       external ptk_locscanmenus !$PRAGMA C(ptk_locscanmenus)

       ans = ptk_locscanmenus(%val(wsid), point, menuid, itemnum, value)
       if (ans .eq. 1) then
          ptkf_locscanmenus = .TRUE.
       else
          ptkf_locscanmenus = .FALSE.
       endif

       RETURN
       END
       
       SUBROUTINE ptkf_setmenuposition(menuid, menupos)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{REAL}{menupos(2)}{menu position}{IN}
C ** \paramend
C ** \blurb{This function sets the position of the top-left corner of the
C ** first menu item. The position is given in the range [0, 1]. If the
C ** position results in part of the menu being clipped then the actual
C ** position is adjusted so that as much as possible of the menu is 
C ** visible.}
C */
       INTEGER menuid
       REAL menupos(2)
       external ptk_setmenuposition !$PRAGMA C(ptk_setmenuposition)

       call ptk_setmenuposition(%val(menuid), menupos)

       RETURN
       END
       
       SUBROUTINE ptkf_setboxmenutextfont(wsid, menuid, font)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{font}{text font}{IN}
C ** \paramend
C ** \blurb{This function sets the text font of all text menu items in the
C ** menu structure. The menu must be a box menu.}
C */
       INTEGER wsid, menuid, font
       external ptk_setboxmenutextfont 
& !$PRAGMA C(ptk_setboxmenutextfont)

       call ptk_setboxmenutextfont(%val(wsid), %val(menuid), %val(font))

       RETURN
       END

       SUBROUTINE ptkf_setboxmenuattrs(wsid, menuid, 
& menupath, font, textcolour, intcolour, edgecolour, 
& boxtlcolour, boxbrcolour, httextcolour, htintcolour, 
& htedgecolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{menupath}{path of box menu (left, right, up, down)}{IN}
C ** \param{INTEGER}{font}{text font}{IN}
C ** \param{INTEGER}{textcolour}{colour index for text}{IN}
C ** \param{INTEGER}{intcolour}{colour index for interior}{IN}
C ** \param{INTEGER}{edgecolour}{colour index for edges}{IN}
C ** \param{INTEGER}{boxtlcolour}{colour index for top-left of box}{IN}
C ** \param{INTEGER}{boxcolour}{colour index for bottom-right of box}{IN}
C ** \param{INTEGER}{httextcolour}{colour index for highlight text}{IN}
C ** \param{INTEGER}{htintcolour}{colour index for highlight interior}{IN}
C ** \param{INTEGER}{htedgecolour}{colour index for highlight edges}{IN}
C ** \paramend
C ** \blurb{This function sets the box menu path, text font and colour attribute
C ** values. The highlight colour indicies are used by the function
C ** {\tt ptk\_setboxmenuhighlightitem} to highlight a single menu item.}
C */
       INTEGER wsid, menuid, menupath, font
       INTEGER textcolour, intcolour, edgecolour
       INTEGER boxtlcolour, boxbrcolour
       INTEGER httextcolour, htintcolour, htedgecolour
       external ptk_setboxmenuattrs
& !$PRAGMA C(ptk_setboxmenuattrs)

       call ptk_setboxmenuattrs(%val(wsid), %val(menuid), 
& %val(menupath), %val(font), %val(textcolour), %val(intcolour), 
& %val(edgecolour), %val(boxtlcolour), %val(boxbrcolour), 
& %val(httextcolour), %val(htintcolour), %val(htedgecolour))

       RETURN
       END
       
       SUBROUTINE ptkf_setboxmenuhighlightitem(menuid, itemnum)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{itemnum}{menu item number}{IN}
C ** \paramend
C ** \blurb{This function highlights a menu item by setting the colour
C ** index values for the text, interior and edge of a box menu item.}
C */
       INTEGER menuid, itemnum
       external ptk_setboxmenuhighlightitem 
& !$PRAGMA  C(ptk_setboxmenuhighlightitem)

       call ptk_setboxmenuhighlightitem(%val(menuid), %val(itemnum))

       RETURN
       END
       
       SUBROUTINE ptkf_clearboxmenuhighlight(menuid)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \paramend
C ** \blurb{This function returns the attributes of the highlighted menu item
C ** to their original values. If no item is highlighted the function is
C ** ignored.}
C */
       INTEGER menuid
       external ptk_clearboxmenuhighlight 
& !$PRAGMA  C(ptk_clearboxmenuhighlight)

       call ptk_clearboxmenuhighlight(%val(menuid))

       RETURN
       END
       
       SUBROUTINE ptkf_inqpostedmenus(wsid, num, menuids, totalnum, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{size}{size of buffer}{IN}
C ** \param{INTEGER}{menuids(*)}{list of posted menus}{OUT}
C ** \param{INTEGER}{totalsize}{length of posted menus list}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to inquire the list of all menus
C ** which are posted to workstation {\tt wsid}.}
C */
       INTEGER wsid, num, menuids(num), totalnum, err
       external ptkc_inqpostedmenus !$PRAGMA C(ptkc_inqpostedmenus)

       call ptkc_inqpostedmenus(%val(wsid), %val(num), menuids, 
& totalnum, err)

       RETURN
       END
       
       SUBROUTINE ptkf_inqmenuids(num, menuids, totalnum, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{size}{size of buffer}{IN}
C ** \param{INTEGER}{menuids(*)}{list of menus}{OUT}
C ** \param{INTEGER}{totalsize}{length of menus list}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain a list of all menus
C ** in the PHIGS Toolkit menu store.}
C */
       INTEGER num, menuids(num), totalnum, err
       external ptkc_inqmenuids !$PRAGMA C(ptkc_inqmenuids)

       call ptkc_inqmenuids(%val(num), menuids, totalnum, err)

       RETURN
       END
       
       SUBROUTINE ptkf_inqmenustructid(menuid, menustid, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{menustid}{menu structure identifier}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the identifier
C ** of a menu structure.}
C */
       INTEGER menuid, menustid, err
       external ptk_inqmenustructid !$PRAGMA C(ptk_inqmenustructid)

       call ptk_inqmenustructid(%val(menuid), menustid, err)

       RETURN
       END
       
       SUBROUTINE ptkf_inqmenuname(menuid, menuname, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{windid}{menu identifier}{IN}
C ** \param{INTEGER}{name}{menu name}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the menu name 
C ** for use in the pick filter.}
C */
       INTEGER menuid, menuname, err
       external ptk_inqmenuname !$PRAGMA C(ptk_inqmenuname)
      
       call ptk_inqmenuname(%val(menuid), menuname, err)

       RETURN
       END
       
       LOGICAL FUNCTION ptkf_inqfrontbackmenuid(wsid, frontid, backid,
& err)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{frontstid}{front menu identifier}{OUT}
C ** \param{INTEGER}{backstid}{back menu identifier}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the menu identifiers
C ** of the front and back menus which are posted to workstation {\tt wsid}. 
C ** These are the menus with the highest and lowest post priority.}
C ** 
C */
       INTEGER wsid, frontid, backid, err
       LOGICAL*1 ptk_inqfrontbackmenuid, ans
       external ptk_inqfrontbackmenuid 
& !$PRAGMA C(ptk_inqfrontbackmenuid)

       ans = ptk_inqfrontbackmenuid(%val(wsid), frontid, backid, err)
       if (ans .eq. 1) then
          ptkf_inqfrontbackmenuid = .TRUE.
       else
          ptkf_inqfrontbackmenuid = .FALSE.
       endif

       RETURN
       END

       SUBROUTINE ptkf_inqmenuposition(menuid, position, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{REAL}{position(2)}{menu position}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the position of the
C ** top-left corner of first menu item. The position is returned in the
C ** range [0, 1].}
C */
       INTEGER menuid
       REAL position(2)
       INTEGER err
       external ptk_inqmenuposition !$PRAGMA C(ptk_inqmenuposition)

       call ptk_inqmenuposition(%val(menuid), position, err)

       RETURN
       END

       SUBROUTINE ptkf_inqboxmenuhighlightitem(menuid, item, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{item}{hightlight item number}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the item number of the
C ** currently highlight box menu item.}
C */
       INTEGER menuid, item, err
       external ptk_inqboxmenuhighlightitem 
& !$PRAGMA C(ptk_inqboxmenuhighlightitem)

       call ptk_inqboxmenuhighlightitem(%val(menuid), item, err)

       RETURN
       END

       SUBROUTINE ptkf_inqboxmenuattrs(menuid, menupath,
& font, textcolour, intcolour, edgecolour, boxtlcolour, boxbrcolour, 
& httextcolour, htintcolour, htedgecolour, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{Ptxpath *}{menupath}{path of box menu (left, right, up, down)}{OUT}
C ** \param{INTEGER}{font}{text font}{OUT}
C ** \param{INTEGER}{textcolour}{colour index for text}{OUT}
C ** \param{INTEGER}{intcolour}{colour index for interior}{OUT}
C ** \param{INTEGER}{edgecolour}{colour index for edges}{OUT}
C ** \param{INTEGER}{boxtlcolour}{colour index for top-left of box}{OUT}
C ** \param{INTEGER}{boxcolour}{colour index for bottom-right of box}{OUT}
C ** \param{INTEGER}{httextcolour}{colour index for highlight text}{OUT}
C ** \param{INTEGER}{htintcolour}{colour index for highlight interior}{OUT}
C ** \param{INTEGER}{htedgecolour}{colour index for highlight edges}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the boxmenu attribute
C ** values for {\tt menuid}. These include the menu path, text font and
C ** colour indicies.}
C */
       INTEGER menuid, menupath, font, textcolour, intcolour
       INTEGER edgecolour, boxtlcolour, boxbrcolour
       INTEGER httextcolour, htintcolour, htedgecolour, err
       external ptk_inqboxmenuattrs
& !$PRAGMA C(ptk_inqboxmenuattrs)

       call ptk_inqboxmenuattrs(%val(menuid), menupath,
& font, textcolour, intcolour, edgecolour, boxtlcolour, 
& boxbrcolour, httextcolour, htintcolour, htedgecolour, err)

       RETURN
       END

       SUBROUTINE ptkf_createrotator(wsid, menuid, rottype, size, 
& titlestr,  titleheight)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{rotator identifier}{IN}
C ** \param{INTEGER}{rottype}{rotator type}{IN}
C ** \param{REAL}{size(2)}{rotator size}{IN}
C ** \param{CHARACTER*(*)}{titlestr}{rotator title}{IN}
C ** \param{REAL}{titleheight}{rotator title height}{IN}
C ** \paramend
C ** \blurb{This function creates a special form of user menu called a
C ** rotator. Rotators consist of an arrangement of arrows and are useful
C ** for defining rotation values and direction in a user interface.
C ** There are three types of rotator available: 1D, 2D and 3D, and each
C ** having an increasing number of arrows.}
C */

       INTEGER wsid, menuid, rottype
       REAL size(2)
       CHARACTER*(*) titlestr
       REAL titleheight
       REAL*8 dptitleheight
       CHARACTER*255 inbuf
       external ptk_createrotator !$PRAGMA C(ptk_createrotator)

       inbuf = titlestr//'\0'
       dptitleheight = titleheight
       call ptk_createrotator(%val(wsid), %val(menuid), %val(rottype), 
& size, inbuf, %val(dptitleheight))

       RETURN
       END
       
       SUBROUTINE ptkf_setrotatortitle(menuid, titlestr)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{CHARACTER*(*)}{titlestr}{title string of rotator banner}{IN}
C ** \paramend 
C ** \blurb{This function sets the title string of the rotator menu
C ** to be {\tt titlestr}. The string is automatically scaled to fit
C ** in the rotator title box.}
C */
       INTEGER menuid
       CHARACTER*(*) titlestr
       CHARACTER*255 inbuf
       external ptk_setrotatortitle !$PRAGMA C(ptk_setrotatortitle)

       inbuf = titlestr//'\0'
       call ptk_setrotatortitle(%val(menuid), inbuf)

       RETURN
       END

       SUBROUTINE ptkf_setrotatorattrs(wsid, menuid, 
& titlefont, titlecolour, arrowcolour, arrowedgecolour,
& intcolour, edgecolour, bannercolour, 
& boxtlcolour, boxbrcolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{menuid}{rotator identifier}{IN}
C ** \param{INTEGER}{titlefont}{title font}{IN}
C ** \param{INTEGER}{titlecolour}{title colour index}{IN}
C ** \param{INTEGER}{arrowcolour}{arrow interior colour index}{IN}
C ** \param{INTEGER}{arrowedgecolour}{arrow edge colour index}{IN}
C ** \param{INTEGER}{intcolour}{rotator interior colour index}{IN}
C ** \param{INTEGER}{edgecolour}{edge colour index}{IN}
C ** \param{INTEGER}{bannercolour}{banner colour index}{IN}
C ** \param{INTEGER}{boxtlcolour}{top-left colour index}{IN}
C ** \param{INTEGER}{boxbrcolour}{bottom-right colour index}{IN}
C ** \paramend
C ** \blurb{This function sets the attribute values of a rotator menu.
C ** The arrows are drawn within a box similar to that of box menu
C ** items and the box has an area for a title string. All arrows
C ** are drawn with the same colour values defined by {\tt arrowcolour}
C ** for the interior and {\tt arrowedgecolour} for the outline.}
C */
       INTEGER wsid, menuid, titlefont
       INTEGER titlecolour, arrowcolour, arrowedgecolour
       INTEGER intcolour, edgecolour, bannercolour
       INTEGER boxtlcolour, boxbrcolour
       external ptk_setrotatorattrs
& !$PRAGMA C(ptk_setrotatorattrs)

       call ptk_setrotatorattrs(%val(wsid), %val(menuid), 
& %val(titlefont), %val(titlecolour), %val(arrowcolour),
& %val(arrowedgecolour), %val(intcolour), 
& %val(edgecolour), %val(bannercolour), 
& %val(boxtlcolour), %val(boxbrcolour))

       RETURN
       END

       SUBROUTINE ptkf_inqrotatortitle(menuid, len, titlestr, totlen,
& err)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{menu identifier}{IN}
C ** \param{INTEGER}{len}{length of string}{IN}
C ** \param{CHARACTER*(*)}{titlestr}{title string of rotator banner}{IN}
C ** \param{INTEGER}{totlen}{actual length of string}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend 
C ** \blurb{This function may be used to obtain the title string of a rotator
C ** menu.}
C */
       INTEGER menuid, len
       CHARACTER*(*) titlestr
       INTEGER totlen, err
       CHARACTER*255 inbuf
       external ptk_inqrotatortitle !$PRAGMA C(ptk_inqrotatortitle)

       call ptk_inqrotatortitle(menuid, %val(len), titlestr, totlen,
& err) 
       totlen = totlen - 1
       if (len .le. 255) then
         titlestr = inbuf(1:totlen)
       endif

       RETURN
       END

       SUBROUTINE ptkf_inqrotatorattrs(menuid, 
& titlefont, titlecolour, arrowcolour, arrowedgecolour, 
& intcolour, edgecolour, bannercolour, boxtlcolour, 
& boxbrcolour, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{menuid}{rotator identifier}{IN}
C ** \param{INTEGER}{titlefont}{title font}{OUT}
C ** \param{INTEGER}{titlecolour}{title colour index}{OUT}
C ** \param{INTEGER}{arrowcolour}{arrow interior colour index}{OUT}
C ** \param{INTEGER}{arrowedgecolour}{arrow edge colour index}{OUT}
C ** \param{INTEGER}{intcolour}{rotator interior colour index}{OUT}
C ** \param{INTEGER}{edgecolour}{edge colour index}{OUT}
C ** \param{INTEGER}{bannercolour}{banner colour index}{OUT}
C ** \param{INTEGER}{boxtlcolour}{top-left colour index}{OUT}
C ** \param{INTEGER}{boxbrcolour}{bottom-right colour index}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the attribute values of
C ** a rotator menu.}
C */
       INTEGER menuid, titlefont, titlecolour, arrowcolour
       INTEGER arrowedgecolour, intcolour
       INTEGER edgecolour, bannercolour, boxtlcolour
       INTEGER boxbrcolour, err
       external ptk_inqrotatorattrs !$PRAGMA C(ptk_inqrotatorattrs)

       call ptk_inqrotatorattrs(%val(menuid), 
& titlefont, titlecolour, arrowcolour, arrowedgecolour, 
& intcolour, edgecolour, bannercolour, boxtlcolour, 
& boxbrcolour, err)

       RETURN
       END
       
C     end of menu.f
